# Coloured Petri Net (CPN): Implementation
# Release: Development
#
# Copyright (c) 2002 Torvald Riegel. All rights reserved. This program is
# free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.
#
# Copyright (c) 2011 Brent R. Scott. All rights reserved. This program has
# been modified from the original release and is free software. You can 
# redistribute it and/or modify it under the same terms as Perl itself.

package CPN;

use strict;
use Data::Dumper;
use Carp;
use CPN::Place;
use CPN::Transition;
use CPN::Transition::ArcIn;
use CPN::Transition::ArcOut;
use vars qw($VERSION);

$VERSION = '0.011';

sub new {
    my $type = shift;
    my $self = bless {
                      places => {},
                      placesInv => {},  # inverse: place_obj -> name
                      transitions => {},
                      placeTransitionRel => {},
                      transitionExecuteQueue => [],
                     }, $type;
    return $self;
}


#########################
# Place Accessors		#
#########################

# Params: An @array of place names.
sub addPlace {
    my $self = shift;
    while (@_) {
      my $place = shift;
      if (not defined $self->{places}->{$place}) {
    	my $newPlace=CPN::Place->new(
    	                              name => $place,
    	                              net  => $self,
    	                            );
        $self->{places}->{$place} = $newPlace;
        $self->{placesInv}->{$newPlace} = $place;
        #$newPlace->setNet($self);
      }
    }
}

# Params: Name of Place
sub getPlace {
    my ($self, $place) = @_;
    croak "no such place" unless $self->existsPlace($place);
    return $self->{places}->{$place};
}

# Params: Name of Place
sub removePlace {
    my ($self, $place) = @_;
    croak "no such place" unless $self->existsPlace($place);
    $self->{places}->{$place}->setNet(undef);
    delete $self->{placesInv}->{$self->{places}->{$place}};
    delete $self->{places}->{$place};
    carp "linked transitions left: ".
      join(',', @{$self->{placeTransitionRel}->{$place}})
      if defined @{$self->{placeTransitionRel}->{$place}};
    delete $self->{placeTransitionRel}->{$place};
}

# Params: Name of Place
sub existsPlace {
    my ($self, $place) = @_;
    return exists $self->{places}->{$place};
}

#########################
# Transition Accessors	#
#########################

# Params: An @array of transition names.
sub addTransition {
    my $self = shift;
    while (@_) {
      my $transition = shift;
      if (not defined $self->{transitions}->{$transition}) {
      	my $newTransition=CPN::Transition->new(name => $transition);
        $self->{transitions}->{$transition} = $newTransition;
        $newTransition->setNet($self);
      }
    }
}

# Params: Name of Transition
sub removeTransition {
    my ($self, $transition) = (shift, shift);
    foreach (keys %{$self->{transitions}->{$transition}->getInputPlaces()}) {
        @{$self->{placeTransitionRel}->{$_}} = grep ($_ ne $transition,
          @{$self->{placeTransitionRel}->{$_}});
    }
    delete $self->{transitions}->{$transition};
}

# Params: Name of Transition
sub existsTransition {
    my ($self, $trans) = @_;
    return exists $self->{transitions}->{$trans}
}


#########################
# Token Notifications	#
#########################

# Params: ref to/name of place, token ids
sub tokenAdded {
    my ($self, $place) = (shift, shift);
    $place = $self->{placesInv}->{$place}
      if UNIVERSAL::isa($place, 'CPN::Place');
    foreach (@{$self->{placeTransitionRel}->{$place}}) {
        $self->{transitions}->{$_}->tokenAdded($place, @_);
    }
}

sub tokenRemoved {
    my ($self, $place) = (shift, shift);
    $place = $self->{placesInv}->{$place}
      if UNIVERSAL::isa($place, 'CPN::Place');
    foreach (@{$self->{placeTransitionRel}->{$place}}) {
        $self->{transitions}->{$_}->tokenRemoved($place, @_);
    }
}

#########################
# Net Actions			#
#########################

# Params: References to Places, Transitions and Arcs
sub buildNet {
  my ($self, $p, $t, $a) = @_;
  # Create Places
  $self->addPlace(keys(%{$p}));

  # Add Tokens to Places
  foreach (keys(%{$p})) {
	$self->{places}->{$_}->addToken(@{$p->{$_}});
  }

  # Create Tranistions
  $self->addTransition(keys(%{$t}));

  # Create Input Arcs
  foreach my $trans (keys(%{$a->{input}})) {
	foreach my $inPlace (keys (%{$a->{input}->{$trans}})) {
	  $self->{transitions}->{$trans}->setArcIn($inPlace, $a->{input}->{$trans}->{$inPlace});
	}
  }

  # Create Output Arcs
  foreach my $trans (keys(%{$a->{output}})) {
	foreach my $outPlace (keys (%{$a->{output}->{$trans}})) {
	  $self->{transitions}->{$trans}->setArcOut($outPlace, $a->{output}->{$trans}->{$outPlace});
	}
  }
}

# Initialize Net - Find All Enabled Transactions
sub initNet {
}

# Clear the Net
# TODO: Need to remove stale places and transitions.
sub clearNet {
    my $self = shift;
    foreach (keys %{$self->{places}}) {
        $self->removePlace($_);
    }
    $self->{transitions} = {};
}


# Execute Steps
# Params: maxsteps=1
# Returns: true if there could be more enabled steps
sub executeSteps {
    my ($self, $maxsteps) = @_;
    $maxsteps = 1 unless $maxsteps;
    my $transitions_tried = 0;
    my $noSteps = 0;
    while ($maxsteps and $transitions_tried < keys %{$self->{transitions}}) {
        # provides a new transition ordering if needed (round robin)
        unless (@{$self->{transitionExecuteQueue}}) {
            push(@{$self->{transitionExecuteQueue}},
                 keys %{$self->{transitions}} );
        }
        $transitions_tried++;
        # let the transition execute one step
        if ($self->{transitions}->{shift @{$self->{transitionExecuteQueue}}}
            ->executeStep()) {
            $maxsteps--;
        }
        if ($maxsteps) {
            # noSteps state if all transitions tried and $maxsteps left
            $noSteps = 1 if $transitions_tried == keys %{$self->{transitions}};
        }
    }
    # TODO return no_steps state ?
    return !$noSteps;
}

#########################
# Net State				#
#########################

# Params: Name of a place (optional)
# Returns: Hash of Places=>Tokens 
#          OR Array of Tokens if Place is Provided.
sub getStatePlaces {
	my ($self, $place) = @_;
	if (not defined $place) {
	  my $placeTokens = {};
	  foreach (keys %{$self->{places}}) {
		@{$$placeTokens{$_}} = $self->{places}->{$_}->getAllTokens;
	  }
	  return $placeTokens;
	} else {
      return $self->{places}->{$place}->getAllTokens;
	}
}

1;
